Aminet 1/Aminet - June 1993 [Walnut Creek].iso/usenet/sources/volume2/aplictns/hoc.1

Text File | 1988-11-10 | 30.9 KB | 1,511 lines

Path: xanth!nic.MR.NET!tank!mimsy!dftsrv!ukma!mailrus!ulowell!page
From: [e-mail] (Bob Page)
Newsgroups: comp.sources.amiga
Subject: v02i057:  hoc - interactive floating point interpreter
Message-ID: <[e-mail]>
Date: 10 Nov 88 01:53:42 GMT
Organization: University of Lowell, Computer Science Dept.
Lines: 1500
Approved: [e-mail]

Submitted-by: [e-mail] (Sam Paolucci)
Posting-number: Volume 2, Issue 57
Archive-name: applications/hoc.1

Hoc is a programmable interpreter for floating point expressions.  The
code was originally written by none other than Brian Kernighan and Rob
Pike, and documented in their book "The UNIX Programming Environment".
I added other builtin functions that were not in the original version.

#    This is a shell archive.
#    Remove everything above and including the cut line.
#    Then run the rest of the file through sh.
#----cut here-----cut here-----cut here-----cut here----#
#!/bin/sh
# shar:    Shell Archiver
#    Run the following text with /bin/sh to create:
#    README
#    code.c
#    hoc.1.cat
#    hoc.1.man
#    hoc.h
#    hoc.ms
#    hoc.y
#    init.c
#    makefile
#    makefile.unix
#    math.c
#    symbol.c
#    test.hoc
# This archive created: Wed Nov  9 20:47:06 1988
cat << \SHAR_EOF > README
                NOTES
                -----

Hoc is a programmable interpreter for floating point expressions.  The
code was originally written by none other than Brian Kernighan and Rob
Pike, and documented in their book "The UNIX Programming Environment".
I ported the program to the Amiga since I had a need for it.  Along
the way I added other builtin functions that were not in the original
version.  These additions are reflected in the documetation that is
included.  In addition to a manual page, I have also included the
troff documentation for hoc along with its PostScript output.

I was hoping to add the error function as well as the bessel and gamma
functions before letting it out the door, but due to lack of time they
will have to wait for a future update.

                        Enjoy.

Dr. Samuel Paolucci
1351 Roselli Dr.
Livermore, CA 94550
[phone]

ARPA: [e-mail]
SHAR_EOF
cat << \SHAR_EOF > code.c
#include "hoc.h"
#include "y.tab.h"
#include <stdio.h>

#define NSTACK    256

static Datum stack[NSTACK];    /* the stack */
static Datum *stackp;        /* next free spot on stack */

#define NPROG    2000
Inst    prog[NPROG];        /* the machine */
Inst    *progp;            /* next free spot for code generation */
Inst    *pc;            /* program counter during execution */
Inst    *progbase = prog;    /* start of current subprogram */
int    returning;        /* 1 if return stmt seen */

typedef struct Frame {        /* proc/func call stack frame */
    Symbol    *sp;        /* symbol table entry */
    Inst    *retpc;        /* where to resume after return */
    Datum    *argn;        /* n-th argument on stack */
    int    nargs;        /* number of arguments */
} Frame;

#define NFRAME    100
Frame    frame[NFRAME];
Frame    *fp;            /* frame pointer */

initcode()
{
    progp = progbase;
    stackp = stack;
    fp = frame;
    returning = 0;
}

push(d)
Datum d;
{
    if (stackp >= &stack[NSTACK])
        execerror("stack too deep", (char *) 0);
    *stackp++ = d;
}

Datum pop()
{
    if (stackp == stack)
        execerror("stack underflow", (char *) 0);
    return *--stackp;
}

constpush()
{
    Datum d;
    d.val = ((Symbol *)*pc++)->u.val;
    push(d);
}

varpush()
{
    Datum d;
    d.sym = (Symbol *)(*pc++);
    push(d);
}

whilecode()
{
    Datum d;
    Inst *savepc = pc;

    execute(savepc + 2);            /* condition */
    d = pop();
    while (d.val) {
        execute(*((Inst **)(savepc)));    /* body */
        if (returning)
            break;
        execute(savepc + 2);        /* condition */
        d = pop();
    }
    if (!returning)
        pc = *((Inst **)(savepc + 1));    /* next stmt */
}

ifcode()
{
    Datum d;
    Inst *savepc = pc;            /* then part */

    execute(savepc + 3);            /* condition */
    d = pop();
    if (d.val)
        execute(*((Inst **)(savepc)));
    else if (*((Inst **)(savepc + 1)))    /* else part? */
        execute(*((Inst **)(savepc + 1)));
    if (!returning)
        pc = *((Inst **)(savepc + 2));    /* next stmt */
}

define(sp)    /* put func/proc in symbol table */
Symbol *sp;
{
    sp->u.defn = (Inst)progbase;        /* start of code */
    progbase = progp;            /* next code starts here */
}

call()        /* call a function */
{
    Symbol *sp = (Symbol *)pc[0];        /* symbol table entry */
                        /* for function */
    if (fp++ >= &frame[NFRAME - 1])
        execerror(sp->name, "call nested too deeply");
    fp->sp = sp;
    fp->nargs = (int)pc[1];
    fp->retpc = pc + 2;
    fp->argn = stackp - 1;            /* last argument */
    execute(sp->u.defn);
    returning = 0;
}

ret()        /* common return from func or proc */
{
    int i;
    for (i = 0; i < fp->nargs; i++)
        pop();                /* pop arguments */
    pc = (Inst *)fp->retpc;
    --fp;
    returning = 1;
}

funcret()    /* return from a function */
{
    Datum d;
    if (fp->sp->type == PROCEDURE)
        execerror(fp->sp->name, "(proc) returns value");
    d = pop();            /* preserve function return value */
    ret();
    push(d);
}

procret()    /* return from a procedure */
{
    if (fp->sp->type == FUNCTION)
        execerror(fp->sp->name, "(func) returns no value");
    ret();
}

double *getarg()    /* return pointer to argument */
{
    int nargs = (int) *pc++;
    if (nargs > fp->nargs)
        execerror(fp->sp->name, "not enough arguments");
    return &fp->argn[nargs - fp->nargs].val;
}

arg()        /* push argument onto stack */
{
    Datum d;
    d.val = *getarg();
    push(d);
}

argassign()    /* store top of stack in argument */
{
    Datum d;
    d = pop();
    push(d);    /* leave value on stack */
    *getarg() = d.val;
}

bltin()
{
    Datum d;
    d = pop();
    d.val = (*(double (*)())*pc++)(d.val);
    push(d);
}

eval()        /* evaluate variable on stack */
{
    Datum d;
    d = pop();
    if (d.sym->type != VAR && d.sym->type != UNDEF)
        execerror("attempt to evaluate non-variable", d.sym->name);
    if (d.sym->type == UNDEF)
        execerror("undefined variable", d.sym->name);
    d.val = d.sym->u.val;
    push(d);
}

add()
{
    Datum d1, d2;
    d2 = pop();
    d1 = pop();
    d1.val += d2.val;
    push(d1);
}

sub()
{
    Datum d1, d2;
    d2 = pop();
    d1 = pop();
    d1.val -= d2.val;
    push(d1);
}

mul()
{
    Datum d1, d2;
    d2 = pop();
    d1 = pop();
    d1.val *= d2.val;
    push(d1);
}

div()
{
    Datum d1, d2;
    d2 = pop();
    if (d2.val == 0.0)
        execerror("division by zero", (char *) 0);
    d1 = pop();
    d1.val /= d2.val;
    push(d1);
}

negate()
{
    Datum d;
    d = pop();
    d.val = -d.val;
    push(d);
}

gt()
{
    Datum d1, d2;
    d2 = pop();
    d1 = pop();
    d1.val = (double)(d1.val > d2.val);
    push(d1);
}

lt()
{
    Datum d1, d2;
    d2 = pop();
    d1 = pop();
    d1.val = (double)(d1.val < d2.val);
    push(d1);
}

ge()
{
    Datum d1, d2;
    d2 = pop();
    d1 = pop();
    d1.val = (double)(d1.val >= d2.val);
    push(d1);
}

le()
{
    Datum d1, d2;
    d2 = pop();
    d1 = pop();
    d1.val = (double)(d1.val <= d2.val);
    push(d1);
}

eq()
{
    Datum d1, d2;
    d2 = pop();
    d1 = pop();
    d1.val = (double)(d1.val == d2.val);
    push(d1);
}

ne()
{
    Datum d1, d2;
    d2 = pop();
    d1 = pop();
    d1.val = (double)(d1.val != d2.val);
    push(d1);
}

and()
{
    Datum d1, d2;
    d2 = pop();
    d1 = pop();
    d1.val = (double)(d1.val != 0.0 && d2.val != 0.0);
    push(d1);
}

or()
{
    Datum d1, d2;
    d2 = pop();
    d1 = pop();
    d1.val = (double)(d1.val != 0.0 || d2.val != 0.0);
    push(d1);
}

not()
{
    Datum d;
    d = pop();
    d.val = (double)(d.val == 0.0);
    push(d);
}

power()
{
    Datum d1, d2;
    extern double Pow();
    d2 = pop();
    d1 = pop();
    d1.val = Pow(d1.val, d2.val);
    push(d1);
}

assign()
{
    Datum d1, d2;
    d1 = pop();
    d2 = pop();
    if (d1.sym->type != VAR && d1.sym->type != UNDEF)
        execerror("assignment to non-variable", d1.sym->name);
    d1.sym->u.val = d2.val;
    d1.sym->type = VAR;
    push(d2);
}

print()        /* pop top value from stack, print it */
{
    Datum d;
    d = pop();
    printf("\t%.8g\n", d.val);
}

prexpr()    /* print numeric value */
{
    Datum d;
    d = pop();
    printf("%.8g ", d.val);
}

prstr()        /* print string value */
{
    printf("%s", (char *) *pc++);
}

varread()    /* read into variable */
{
    Datum d;
    extern FILE *fin;
    Symbol *var = (Symbol *) *pc++;
Again:
    switch (fscanf(fin, "%lf", &var->u.val)) {
    case EOF:
        if (moreinput())
            goto Again;
        d.val = var->u.val = 0.0;
        break;
    case 0:
        execerror("non-number read into", var->name);
        break;
    default:
        d.val = 1.0;
        break;
    }
    var->type = VAR;
    push(d);
}

Inst *code(f)    /* install one instruction or operand */
Inst f;
{
    Inst *oprogp = progp;
    if (progp >= &prog[NPROG])
        execerror("program too big", (char *) 0);
    *progp++ = f;
    return oprogp;
}

execute(p)
Inst *p;
{
    for (pc = p; *pc != STOP && !returning; )
        (*(*pc++))();
}



SHAR_EOF
cat << \SHAR_EOF > hoc.1.cat



                                                           HOC(1)



NAME
     hoc - interactive floating point language

SYNOPSIS
     hoc [ file ... ]

DESCRIPTION
     _H_o_c interprets a simple language for floating point arith-
     metic, at about the level of BASIC, with C-like syntax and
     functions and procedures with arguments and recursion.

     The named _f_i_l_es are read and interpreted in order.  If no
     _f_i_l_e is given or if _f_i_l_e is `-' _h_o_c interprets the standard
     input.

     _H_o_c input consists of _e_x_p_r_e_s_s_i_o_n_s and _s_t_a_t_e_m_e_n_t_s.  Expres-
     sions are evaluated and their results printed.  Statements,
     typically assignments and function or procedure definitions,
     produce no output unless they explicitly call _p_r_i_n_t.

SEE ALSO
     _H_o_c - _A_n _I_n_t_e_r_a_c_t_i_v_e _L_a_n_g_u_a_g_e _f_o_r _F_l_o_a_t_i_n_g _P_o_i_n_t _A_r_i_t_h_m_e_t_i_c
     by Brian Kernighan and Rob Pike.
     _b_a_s(1), _b_c(1) and _d_c(1).

BUGS
     Error recovery is imperfect within function and procedure
     definitions.
     The treatment of newlines is not exactly user-friendly.


























                                                                1



SHAR_EOF
cat << \SHAR_EOF > hoc.1.man
.TH HOC 1
.SH NAME
hoc \- interactive floating point language
.SH SYNOPSIS
.B hoc
[ file ... ]
.SH DESCRIPTION
.I Hoc
interprets a simple language for floating point arithmetic,
at about the level of BASIC, with C-like syntax and
functions and procedures with arguments and recursion.
.PP
The named
.IR file s
are read and interpreted in order.
If no
.I file
is given or if
.I file
is `\-'
.I hoc
interprets the standard input.
.PP
.I Hoc
input consists of
.I expressions
and
.IR statements .
Expressions are evaluated and their results printed.
Statements, typically assignments and function or procedure
definitions, produce no output unless they explicitly call
.IR print .
.SH "SEE ALSO"
.I
Hoc \- An Interactive Language for Floating Point Arithmetic
by Brian Kernighan and Rob Pike.
.br
.IR bas (1),
.IR bc (1)
and
.IR dc (1).
.SH BUGS
Error recovery is imperfect within function and procedure definitions.
.br
The treatment of newlines is not exactly user-friendly.
SHAR_EOF
cat << \SHAR_EOF > hoc.h
typedef struct Symbol {    /* symbol table entry */
    char    *name;
    short    type;
    union {
        double    val;        /* VAR            */
        double    (*ptr)();    /* BLTIN        */
        int    (*defn)();    /* FUNCTION, PROCEDURE    */
        char    *str;        /* STRING        */
    } u;
    struct Symbol    *next;        /* to link to another */
} Symbol;
Symbol    *install(), *lookup();

typedef union Datum {    /* interpreter stack type */
    double    val;
    Symbol    *sym;
} Datum;
extern    Datum pop();
extern    eval(), add(), sub(), mul(), div(), negate(), power();

typedef int (*Inst)();
#define STOP    (Inst) 0

extern Inst *progp, *progbase, prog[], *code();
extern assign(), bltin(), varpush(); constpush(), print(), varread();
extern prexpr(), prstr();
extern gt(), lt(), eq(), ge(), le(), ne(), and(), or(), not();
extern ifcode(), whilecode(), call(), arg(), argassign();
extern funcret(), procret();
SHAR_EOF
cat << \SHAR_EOF > hoc.ms
.TL
Hoc - An Interactive Language For Floating Point Arithmetic
.AU
Brian Kernighan
Rob Pike
.AB
.I Hoc
is a simple programmable interpreter
for floating point expressions.
It has C-style control flow,
function definition and the usual
numerical built-in functions
such as cosine and logarithm.
.AE
.NH
Expressions
.PP
.I Hoc
is an expression language,
much like C:
although there are several control-flow statements,
most statements such as assignments
are expressions whose value is disregarded.
For example, the assignment operator
= assigns the value of its right operand
to its left operand, and yields the value,
so multiple assignments work.
The expression grammar is:
.DS
.I
expr:        number
    |    variable
    |    ( expr )
    |    expr binop expr
    |    unop expr
    |    function ( arguments )
.R
.DE
Numbers are floating point.
The input format is that recognized by
.I scanf
(3): digits, decimal point, digits,
.I e
or
.I E,
signed exponent.  At least one digit or a decimal point must be present;
the other components are optional.
.PP
Variable names are formed from a letter followed
by a string of letters and numbers.
.I binop
refers to binary operators such as addition or logical comparison;
.I unop
refers to the two negation operators, `!' (logical negation, `not')
and `\-' (arithmetic negation, sign change).
Table 1 lists the operators.
.TS
center, box;
c s
lfCW l.
\fBTable 1:\fP  Operators, in decreasing order of precedence
.sp .5
^    exponentiation (\s-1FORTRAN\s0 **), right associative
! \-    (unary) logical and arithmetic negation
* /    multiplication, division
+ \-    addition, subtraction
> >=    relational operators: greater, greater or equal,
< <=      less, less or equal,
\&== !=      equal, not equal (all same precedence)
&&    logical AND (both operands always evaluated)
| |    logical OR (both operands always evaluated)
\&=    assignment, right associative
.TE
.PP
Functions, as described later, may be defined by the user.
Function arguments are expressions separated by commas.
There are also a number of built-in functions,
all of which take a single argument, described in Table 2.
.EQ
delim @@
.EN
.TS
center, box;
c s
lfCW l.
\fBTable 2:\fP  Built-in Functions
.sp .5
abs(x)    @|x|@, absolute value of @x@
acos(x)    arc cosine of @x@
asin(x)    arc sine of @x@
atan(x)    arc tangent of @x@
ceil(x)    smallest integer not less than @x@
cos(x)    @cos(x)@, cosine of @x@
cosh(x)    hyperbolic cosine of @x@
exp(x)    @e sup x@, exponential of @x@
floor(x)    largest integer not greater than @x@
int(x)    integer part of @x@, truncated towards zero
log(x)    @log(x)@, logarithm base @e@ of @x@
log10(x)    @log sub 10 (x)@, logarithm base 10 of @x@
ran(x)    random number between 0.0 and 1.0
sin(x)    @sin(x)@, sine of @x@
sinh(x)    hyperbolic sine of @x@
sqrt(x)    @sqrt x@ , @x sup 1/2@
tan(x)    tangent of @x@
tanh(x)    hyperbolic tangent of @x@
.TE
.PP
Logical expressions have value 1.0 (true) and 0.0 (false).
As in C, any non-zero value is taken to be true.
As is always the case with floating point numbers,
equality comparisons are inherently suspect.
.PP
.I Hoc
also has a few built-in constants, shown in Table 3.
.TS
center, box;
c s s
lfCW n l.
\fBTable 3:\fP  Built-in Constants
.sp .5
DEG    57.29577951308232087680        @ 180/ pi @, degrees per radian
E    2.71828182845904523536        @ e @, base of natural logarithms
GAMMA    0.57721566490153286060        @ gamma @, Euler-Mascheroni constant
PHI    1.61803398874989484820        @ ( sqrt 5 +1)/2 @, the golden ratio
PI    3.14159265358979323846        @ pi @, circular transcendental number
.TE
.NH
Statements and Control Flow
.PP
.I Hoc
statements have the following grammar:
.DS
.I
stmt:        expr
    |    variable = expr
    |    procedure ( arglist )
    |    while ( expr ) stmt
    |    if ( expr ) stmt
    |    if ( expr ) stmt else stmt
    |    { stmtlist }
    |    print expr-list
    |    return optional-expr

stmtlist:    (nothing)
    |    stmtlist stmt
.R
.DE
An assignment is parsed by default as a statement rather than
an expression, so assignements typed interactively do not print
their value.
.PP
Note that semicolons are not special to
.I hoc:
statements are terminated by newlines.  This causes some
peculiar behavior.  The following are legal
.I if
statements:
.DS
if (x < 0) print(y) else print(z)

if (x < 0) {
    print(y)
} else {
    print(z)
}
.DE
In the second example, the braces are mandatory:
the newline after the
.I if
would terminate the statement and produce a syntax error
were the brace omitted.
.PP
The syntax and semantics of
.I hoc
control flow facilities are basically the same as in C.  The
.I while
and
.I if
statements are just as in C, except there are no
.I break
or
.I continue
statements.
.NH
Input and Output: \fIread \fBand \fIprint
.PP
The input function
.I read,
like the other built-ins, takes a single argument.
Unlike the built-ins, though, the argument is not an expression:
it is the name of a variable.  The next number (as defined above)
is read from the standard input and assigned to the named variable.
The return value of
.I read
is 1 (true) if a value was read, and 0 (false) if
.I read
encountered end of file or an error.
.PP
Output is generated with the
.I print
statement.  The arguments to
.I print
are a comma-separated list of expressions and strings in double quotes,
as in C.  Newlines must be supplied; they are never provided automatically by
.I print.
.PP
Note that
.I read
is a special built-in function, and therefore takes a single
parenthesized argument, while
.I print
is a statement that takes a comma-separated, unparenthesized list:
.DS
while (read(x)) {
    print "value is ", x, " \en"
}
.DE
.NH
Functions and Procedures
.PP
Functions and procedures are distinct in
.I hoc,
although they are defined by the same mechanism.  This distinction
is simply for run-time error checking: it is an error for a
procedure to return a value, and for a function
.I not
to return one.
.PP
The definition syntax is:
.DS
.I
function:    func name() stmt

procedure:    proc name() stmt
.R
.DE
.I name
may be the name of any variable \(em built-in functions are excluded.
The definition, up to the opening brace or statement, must be on one line, as with the
.I if
statement above.
.PP
Unlike C, the body of a function or procedure may be any statement,
not necessarily a compound (brace-enclosed) statement.  Since semicolons
have no meaning in
.I hoc,
a null procedure body is formed by an empty pair of braces.
.PP
Functions and procedures may take arguments, separated by commas,
when invoked.  Arguments are referred to as in the shell:
.I $3
refers to the third (1-indexed) argument.  They are passed by value
and within functions are semantically equivalent to variables.
It is an error to refer to an argument numbered greater than the
number of arguments passed to the routine.  The error checking
is done dynamically, however, so a routine may have variable
number of arguments if initial arguments affect the number of
arguments to be referenced (as in C's
.I printf
).
.PP
Functions and procedures may recurse, but the stack has limited depth
(about a hundred calls).  The following shows a
.I hoc
definition of Ackermann's function:
.DS
    $ hoc
    func ack() {
        if ($1 == 0) return $2+1
        if ($2 == 0) return ack($1-1, 1)
        return ack($1-1, ack($1, $2-1))
    }
    ack(3, 2)
        29
    ack(3, 3)
        61
    ack(3, 4)
    hoc: stack too deep near line 8
    . . .
.DE
.NH
Examples
.PP
Stirling's formula
.EQ
n!~\~ ~ sqrt {2 n pi} ( n / e ) sup n ( 1 + 1 over { 12 n } )
.EN
.DS
    $ hoc
    func stirl() {
        return sqrt(2*$1*PI) * ($1/E)^$1*(1 + 1/(12*$1))
    }
    stirl(10)
        3628684.7
    stirl(20)
        2.4328818e+18
.DE
.PP
Factorial function,
.I n!
:
.DS
    func fac() if ($1 <= 0) return 1 else return $1 * fac($1-1)
.DE
.PP
Ratio of factorial to Stirling approximation:
.DS
    i = 9
    while ((i = i+1) <= 20) {
        print i, "  ", fac(i)/stirl(i), " \en"
    }
    10   1.0000318
    11   1.0000265
    12   1.0000224
    13   1.0000192
    14   1.0000166
    15   1.0000146
    16   1.0000128
    17   1.0000114
    18   1.0000102
    19   1.0000092
    20   1.0000083
.DE
SHAR_EOF
cat << \SHAR_EOF > hoc.y
%{
#include "hoc.h"
#define code2(c1,c2)    code(c1); code(c2)
#define code3(c1,c2,c3)    code(c1); code(c2); code(c3)
%}
%union {
    Symbol    *sym;    /* symbol table pointer */
    Inst    *inst;    /* machine instruction  */
    int    narg;    /* number of arguments  */
}
%token    <sym>    NUMBER STRING PRINT VAR BLTIN UNDEF WHILE IF ELSE
%token    <sym>    FUNCTION PROCEDURE RETURN FUNC PROC READ
%token    <narg>    ARG
%type    <inst>    expr stmt asgn prlist stmtlist
%type    <inst>    cond while if begin end
%type    <sym>    procname
%type    <narg>    arglist
%right    '='
%left    OR
%left    AND
%left    GT GE LT LE EQ NE
%left    '+' '-'
%left    '*' '/'
%left    UNARYMINUS NOT
%right    '^'
%%
list:      /* nothing */
    | list '\n'
    | list defn '\n'
    | list asgn '\n'  { code2(pop, STOP); return 1; }
    | list stmt '\n'  { code(STOP); return 1; }
    | list expr '\n'  { code2(print, STOP); return 1; }
    | list error '\n' { yyerrok; }
    ;
asgn:      VAR '=' expr { code3(varpush, (Inst)$1, assign); $$ = $3; }
    | ARG '=' expr
        { defnonly("$"); code2(argassign, (Inst)$1); $$ = $3; }
    ;
stmt:      expr  { code(pop); }
    | RETURN { defnonly("return"); code(procret); }
    | RETURN expr
        { defnonly("return"); $$ = $2; code(funcret); }
    | PROCEDURE begin '(' arglist ')'
        { $$ = $2; code3(call, (Inst)$1, (Inst)$4); }
    | PRINT prlist  { $$ = $2; }
    | while cond stmt end {
        ($1)[1] = (Inst)$3;        /* body of loop        */
        ($1)[2] = (Inst)$4; }        /* end, if cond fails    */
    | if cond stmt end {            /* else-less if        */
        ($1)[1] = (Inst)$3;        /* thenpart        */
        ($1)[3] = (Inst)$4; }        /* end, if cond fails    */
    | if cond stmt end ELSE stmt end {    /* if with else        */
        ($1)[1] = (Inst)$3;        /* thenpart        */
        ($1)[2] = (Inst)$6;        /* elsepart        */
        ($1)[3]    = (Inst)$7; }        /* end, if cond fails    */
    | '{' stmtlist '}'    { $$ = $2; }
    ;
cond:      '(' expr ')'    { code(STOP); $$ = $2; }
    ;
while:      WHILE    { $$ = code3(whilecode, STOP, STOP); }
    ;
if:      IF    { $$ = code(ifcode); code3(STOP, STOP, STOP); }
    ;
begin:      /* nothing */        { $$ = progp; }
    ;
end:      /* nothing */        { code(STOP); $$ = progp; }
    ;
stmtlist: /* nothing */        { $$ = progp; }
    | stmtlist '\n'
    | stmtlist stmt
    ;
expr:      NUMBER { $$ = code2(constpush, (Inst)$1); }
    | VAR     { $$ = code3(varpush, (Inst)$1, eval); }
    | ARG     { defnonly("$"); $$ = code2(arg, (Inst)$1); }
    | asgn
    | FUNCTION begin '(' arglist ')'
        { $$ = $2; code3(call, (Inst)$1, (Inst)$4); }
    | READ '(' VAR ')' { $$ = code2(varread, (Inst)$3); }
    | BLTIN '(' expr ')' { $$ = $3; code2(bltin, (Inst)$1->u.ptr); }
    | '(' expr ')'    { $$ = $2; }
    | expr '+' expr    { code(add); }
    | expr '-' expr    { code(sub); }
    | expr '*' expr    { code(mul); }
    | expr '/' expr    { code(div); }
    | expr '^' expr    { code(power); }
    | '-' expr   %prec UNARYMINUS    { $$ = $2; code(negate); }
    | expr GT expr    { code(gt); }
    | expr GE expr    { code(ge); }
    | expr LT expr    { code(lt); }
    | expr LE expr    { code(le); }
    | expr EQ expr    { code(eq); }
    | expr NE expr    { code(ne); }
    | expr AND expr    { code(and); }
    | expr OR expr    { code(or); }
    | NOT expr    { $$ = $2; code(not); }
    ;
prlist:      expr            { code(prexpr); }
    | STRING        { $$ = code2(prstr, (Inst)$1); }
    | prlist ',' expr    { code(prexpr); }
    | prlist ',' STRING    { code2(prstr, (Inst)$3); }
    ;
defn:      FUNC procname    { $2->type = FUNCTION; indef = 1; }
        '(' ')' stmt { code(procret); define($2); indef = 0; }
    | PROC procname    { $2->type = PROCEDURE; indef = 1; }
        '(' ')' stmt { code(procret); define($2); indef = 0; }
    ;
procname: VAR
    | FUNCTION
    | PROCEDURE
    ;
arglist:  /* nothing */        { $$ = 0; }
    | expr            { $$ = 1; }
    | arglist ',' expr    { $$ = $1 + 1; }
    ;
%%
      /* end of grammar */
#include <stdio.h>
#include <ctype.h>
char    *progname;
int    lineno = 1;
#include <signal.h>
#include <setjmp.h>
jmp_buf    begin;
int    indef;
char    *infile;    /* input file name    */
FILE    *fin;        /* input file pointer    */
char    **gargv;    /* global argument list    */
int    gargc;

int    c;        /* global for use by warning() */
yylex()            /* hoc */
{
    while ((c = getc(fin)) == ' ' || c == '\t')
        ;
    if (c == EOF)
        return 0;
    if (c == '.' || isdigit(c)) {    /* number */
        double d;
        ungetc(c, fin);
        fscanf(fin, "%lf", &d);
        yylval.sym = install("", NUMBER, d);
        return NUMBER;
    }
    if (isalpha(c)) {
        Symbol *s;
        char sbuf[100], *p = sbuf;
        do {
            if (p >= sbuf + sizeof(sbuf) - 1) {
                *p = '\0';
                execerror("name too long", sbuf);
            }
            *p++ = c;
        } while ((c = getc(fin)) != EOF && isalnum(c));
        ungetc(c, fin);
        *p = '\0';
        if ((s = lookup(sbuf)) == 0)
            s = install(sbuf, UNDEF, 0.0);
        yylval.sym = s;
        return s->type == UNDEF ? VAR : s->type;
    }
    if (c == '$') {    /* argument? */
        int n = 0;
        while (isdigit(c = getc(fin)))
            n = 10 * n + c - '0';
        ungetc(c, fin);
        if (n == 0)
            execerror("strange $...", (char *)0);
        yylval.narg = n;
        return ARG;
    }
    if (c == '"') {    /* quoted string */
        char sbuf[100], *p, *emalloc();
        for (p = sbuf; (c = getc(fin)) != '"'; p++) {
            if (c == '\n' || c == EOF)
                execerror("missing quote", "");
            if (p >= sbuf + sizeof(sbuf) - 1) {
                *p = '\0';
                execerror("string too long", sbuf);
            }
            *p = backslash(c);
        }
        *p = 0;
        yylval.sym = (Symbol *)emalloc(strlen(sbuf + 1));
        strcpy(yylval.sym, sbuf);
        return STRING;
    }
    switch (c) {
    case '>':    return follow('=', GE, GT);
    case '<':    return follow('=', LE, LT);
    case '=':    return follow('=', EQ, '=');
    case '!':    return follow('=', NE, NOT);
    case '|':    return follow('|', OR, '|');
    case '&':    return follow('&', AND, '&');
    case '\n':    lineno++; return '\n';
    default:    return c;
    }
}

backslash(c)    /* get next char with \'s interpreted */
int c;
{
    char *index();    /* `strchr()' in some systems */
    static char transtab[] = "b\bf\fn\nr\rt\t";
    if (c != '\\')
        return c;
    c = getc(fin);
    if (islower(c) && index(transtab, c))
        return index(transtab, c)[1];
    return c;
}

follow(expect, ifyes, ifno)    /* look ahead for >=, etc. */
{
    int c = getc(fin);

    if (c == expect)
        return ifyes;
    ungetc(c, fin);
    return ifno;
}

defnonly(s)    /* warn if illegal definition */
char *s;
{
    if (!indef)
        execerror(s, "used outside definition");
}

yyerror(s)    /* report compile-time error */
char *s;
{
    warning(s, (char *)0);
}

execerror(s, t)    /* recover from run-time error */
char *s, *t;
{
    warning(s, t);
    fseek(fin, 0L, 2);    /* flush rest of file */
    longjmp(begin, 0);
}

fpecatch()    /* catch floating point exceptions */
{
    execerror("floating point exception", (char *)0);
}

main(argc, argv)    /* hoc */
int argc;
char *argv[];
{
    int i, fpecatch();

    progname = argv[0];
    if (argc == 1) {    /* fake an argument list */
        static char *stdinonly[] = { "-" };

        gargv = stdinonly;
        gargc = 1;
    } else {
        gargv = argv + 1;
        gargc = argc - 1;
    }
    init();
    while (moreinput())
        run();
    return 0;
}

moreinput()
{
    if (gargc-- <= 0)
        return 0;
    if (fin && fin != stdin)
        fclose(fin);
    infile = *gargv++;
    lineno = 1;
    if (strcmp(infile, "-") == 0) {
        fin = stdin;
        infile = 0;
    } else if ((fin = fopen(infile, "r")) == NULL) {
        fprintf(stderr, "%s: can't open %s\n", progname, infile);
        return moreinput();
    }
    return 1;
}

run()    /* execute until EOF */
{
    setjmp(begin);
    signal(SIGFPE, fpecatch);
    for (initcode(); yyparse(); initcode())
        execute(progbase);
}

warning(s, t)    /* print warning message */
char *s, *t;
{
    fprintf(stderr, "%s: %s", progname, s);
    if (t)
        fprintf(stderr, " %s", t);
    if (infile)
        fprintf(stderr, " in %s", infile);
    fprintf(stderr, " near line %d\n", lineno);
    while (c != '\n' && c != EOF)
        c = getc(fin);    /* flush rest of input line */
    if (c == '\n')
        lineno++;
}


SHAR_EOF
cat << \SHAR_EOF > init.c
#include "hoc.h"
#include "y.tab.h"
#include <math.h>

extern double Log(), Log10(), Sqrt(), Exp(), Sinh(), Cosh(), Tanh(), Ran(), integer();

static struct {        /* Keywords */
    char    *name;
    int    kval;
} keywords[] = {
    "proc",        PROC,
    "func",        FUNC,
    "return",    RETURN,
    "if",        IF,
    "else",        ELSE,
    "while",    WHILE,
    "print",    PRINT,
    "read",        READ,
    0,        0
};

static struct {        /* Constants */
    char    *name;
    double    cval;
} consts[] = {
    "PI",        3.14159265358979323846,
    "E",        2.71828182845904523536,
    "GAMMA",    0.57721566490153286060,        /* Euler */
    "DEG",           57.29577951308232087680,        /* deg/radian */
    "PHI",        1.61803398874989484820,        /* golden ratio */
    0,        0
};

static struct {        /* Built-ins */
    char    *name;
    double    (*func)();
} builtins[] = {
    "sin",        sin,
    "cos",        cos,
    "tan",        tan,
    "asin",        asin,
    "acos",        acos,
    "atan",        atan,
    "sinh",        Sinh,        /* checks range */
    "cosh",        Cosh,        /* checks range */
    "tanh",        Tanh,        /* checks range */
    "log",        Log,        /* checks range */
    "log10",    Log10,        /* checks range */
    "exp",        Exp,        /* checks range */
    "sqrt",        Sqrt,        /* checks range */
    "int",        integer,
    "abs",        fabs,
    "ceil",        ceil,
    "floor",    floor,
    "ran",        Ran,
    0,        0
};

init()        /*install constants and built-ins in table */
{
    int i;
    Symbol *s;
    for (i = 0; keywords[i].name; i++)
        install(keywords[i].name, keywords[i].kval, 0.0);
    for (i = 0; consts[i].name; i++)
        install(consts[i].name, VAR, consts[i].cval);
    for (i = 0; builtins[i].name; i++) {
        s = install(builtins[i].name, BLTIN, 0.0);
        s->u.ptr = builtins[i].func;
    }
}

SHAR_EOF
cat << \SHAR_EOF > makefile
CFLAGS = +L +fi

OBJS = hoc.o code.o init.o math.o symbol.o

hoc:    $(OBJS)
    ln -o hoc $(OBJS) -lma32 -lc32

hoc.o y.tab.h: hoc.c

hoc.o code.o init.o symbol.o: hoc.h

code.o init.o symbol.o: y.tab.h

hoc.c: hoc.y
    yacc -d hoc.y
    @copy y.tab.c hoc.c
SHAR_EOF
cat << \SHAR_EOF > makefile.unix
YFLAGS = -d
OBJS = hoc.o code.o init.o math.o symbol.o

hoc:    $(OBJS)
    cc $(CFLAGS) $(OBJS) -lm -o hoc

hoc.o code.o init.o symbol.o: hoc.h

code.o init.o symbol.o: x.tab.h

x.tab.h:    y.tab.h
    -cmp -s x.tab.h y.tab.h || cp y.tab.h x.tab.h

pr:    hoc.y hoc.h code.c init.c math.c symbol.c
    @pr $?
    @touch pr

clean:
    rm -f $(OBJS) [xy].tab.[ch]
SHAR_EOF
cat << \SHAR_EOF > math.c
#include <math.h>
#include <errno.h>
extern int    errno;
double        errcheck();

double Log(x)
double x;
{
    return errcheck(log(x), "log");
}

double Log10(x)
double x;
{
    return errcheck(log10(x), "log10");
}

double Sqrt(x)
double x;
{
    return errcheck(sqrt(x), "sqrt");
}

double Exp(x)
double x;
{
    return errcheck(exp(x), "exp");
}

double Pow(x, y)
double x, y;
{
    return errcheck(pow(x, y), "exponentiation");
}

double Sinh(x)
double x;
{
    return errcheck(sinh(x), "sinh");
}

double Cosh(x)
double x;
{
    return errcheck(cosh(x), "cosh");
}

double Tanh(x)
double x;
{
    return errcheck(tanh(x), "tanh");
}

#define RAND_MAX 32767

double Ran(x)
double x;
{
    long time();
    srand( (int) time( (long *)0 ) );
    return (rand() / (RAND_MAX + 1.0) );
}

double integer(x)
double x;
{
    return (double)(long)x;
}

double errcheck(d, s)    /* check result of library call */
double d;
char *s;
{
    if (errno == EDOM) {
        errno = 0;
        execerror(s, "argument out of domain");
    } else if (errno == ERANGE) {
        errno = 0;
        execerror(s, "result out of range");
    }
    return d;
}
SHAR_EOF
cat << \SHAR_EOF > symbol.c
#include "hoc.h"
#include "y.tab.h"

static Symbol *symlist = 0;    /* symbol table: linked list */

Symbol *lookup(s)        /* find s in symbol table */
char *s;
{
    Symbol *sp;

    for (sp = symlist; sp != (Symbol *) 0; sp = sp->next)
        if (strcmp(sp->name, s) == 0)
            return sp;
    return 0;    /* 0 ==> not found */
}

Symbol *install(s, t, d)    /* install s in symbol table */
char *s;
int t;
double d;
{
    Symbol *sp;
    char *emalloc();

    sp = (Symbol *) emalloc(sizeof(Symbol));
    sp->name = emalloc(strlen(s) + 1);    /* +1 for '\0' */
    strcpy(sp->name, s);
    sp->type = t;
    sp->u.val = d;
    sp->next = symlist;    /* put at front of list */
    symlist = sp;
    return sp;
}

char *emalloc(n)    /* check return from malloc */
unsigned n;
{
    char *p, *malloc();

    p = malloc(n);
    if (p == 0)
        execerror("out of memory", (char *) 0);
    return p;
}
SHAR_EOF
cat << \SHAR_EOF > test.hoc
func stirl() {
    return sqrt(2*$1*PI) * ($1/E)^$1*(1 + 1/(12*$1))
}
func fac() {
    if ($1 <= 0) return 1 else return $1 * fac($1-1)
}
i = 0
print "     I     FAC(I)/STIRL(I)\n"
while ((i = i+1) <=20) {
    print i, "    ", fac(i)/stirl(i), "\n"
}
SHAR_EOF
#    End of shell archive
exit 0
--
Bob Page, U of Lowell CS Dept.  [e-mail]  ulowell!page
Have five nice days.